perm filename DISTY.F4[PIC,LCS] blob
sn#632759 filedate 1982-01-09 generic text, type T, neo UTF8
DIMENSION I(4),II(4),JIN(3,14000)
COMMON/D/ JD(4000),ID(3,40000) /JJJJ/JP,KP,XS,YS
COMMON NMOUT/OUTER/LFT,RT,TOP,BOT
INTEGER X1,X2,Y1,Y2,LFT,RT,TOP,BOT
EQUIVALENCE (X1,I(2)),(Y1,I(3)),(X2,II(2)),(Y2,II(3)),(J,I(4))
1,(JJ,II(4))
DATA IFIRST/0/
1 FORMAT(' TYPE INPUT NAME '$)
2 FORMAT(' TYPE OUTPUT NAME '$)
3 FORMAT(A5)
4 FORMAT(' TYPE FUNC NAME '$)
6 FORMAT(4I)
81 FORMAT(2I,2F)
66 FORMAT(5X,4I)
80 FORMAT(' X POS, Y POS, X SIZE, Y SIZE '$)
IF(IFIRST)GO TO 95
C DOESN'T READ DATA FILE AFTER 1ST TIME.
IFIRST=-1
TYPE 1
ACCEPT 3,NMIN
CALL IFILE(21,NMIN)
NNN=1
82 READ(21,6,END=94)NN,(JIN(K,NNN),K=1,3)
NNN=NNN+1
GO TO 82
94 NNN=NNN-1
95 NN=0
NX=0
TOP=-9999
BOT=-TOP
LFT=BOT
RT=TOP
TYPE 80
ACCEPT 81,JP,KP,XS,YS
IF(XS.EQ.0)XS=1
IF(YS.EQ.0)YS=1
5 CALL SHFT(I,JIN,NX)
7 IF(NX.EQ.NNN)GO TO 100
CALL SHFT(II,JIN,NX)
99 IF(JJ.EQ.0)GO TO 13
98 CALL NNO(NN)
I(1)=NN
ID(1,NN)=X1
ID(2,NN)=Y1
ID(3,NN)=J
GO TO 8
13 M=1
K=X2-X1
KK=K
IF(K.GE.0)GO TO 10
M=-1
KK=-K
10 L=Y2-Y1
MM=1
LL=L
IF(L.GE.0)GO TO 11
MM=-1
LL=-L
11 IF(LL.GT.KK)GO TO 12
IF(KK.LT.2)GO TO 98
DO 9 N=X1,X2-M,M
A=N-X1
B=K
NY=Y1+L*A/B+.5
CALL NNO(NN)
ID(1,NN)=N
ID(2,NN)=NY
ID(3,NN)=J
C WRITE(22,6)NN,N,NY,J
9 J=0
8 X1=X2
Y1=Y2
J=JJ
GO TO 7
12 IF(LL.LT.2)GO TO 98
DO 19 N=Y1,Y2-MM,MM
A=N-Y1
B=L
NY=X1+K*A/B+.5
CALL NNO(NN)
C TYPE 6,NN,NY,N,J
C WRITE(22,6)NN,NY,N,J
ID(1,NN)=NY
ID(2,NN)=N
ID(3,NN)=J
19 J=0
GO TO 8
COMMON/DL/SIZE /OUTF/NAME,KK,KNT /TTOP/T,TT,TTT,TTTT
1000 FORMAT(' TYPE .PLT NAME '$)
100 CALL NNO(NN)
DO 96 K=1,3
96 ID(K,NN)=II(K+1)
ID(3,NN+1)=-1
CALL DSTO(BOT,TOP)
101 CALL DPY
N=0
TYPE 1000
ACCEPT 3,NAME
IF(NAME.EQ.' ') NAME='PLT'
CALL PLOT(0,600,-3)
102 N=N+1
J=ID(3,N)
IF(J.GT.1)GO TO 102
C SKIP UNNEEDED LINES.
IF(J)GO TO 104
IF(J.GT.0)J=3
IF(J.EQ.0)J=2
CALL PLOT(ID(1,N),ID(2,N),J)
GO TO 102
104 CALL PLOT(ID(1,N),ID(2,N),99)
GO TO 95
103 FORMAT(4I6)
END